home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…ch: Other People's Memory / ADC Developer CD (1993-03) (''Other People's Memory'')_iso / Dev.CD Mar 93.iso / Development Platforms / LISP Related / LISP Goodies / AV Parser / AV Program / graphics.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  23.3 KB  |  726 lines  |  [TEXT/CCL2]
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;;
  3. ;;; av-graphics.lisp
  4. ;;;
  5. ;;; Graphics for the AV Parser for MCL 2.0ß1p3.
  6. ;;;
  7.  
  8. (defpackage :graphics (:use :ccl)
  9.                       (:export ))
  10. (require :pict-scrolling-windows)
  11.  
  12. (defvar *the-view* nil "Dynamically bound to the current scroller view being drawn in")
  13.  
  14. (defparameter *tree-window* nil "Window for drawing trees")
  15. (defparameter *avm-window* nil "Window for drawing avms")
  16.  
  17. ;;; utilities
  18.  
  19. (defun font-size (view)
  20.   "Current font size of window that view is in"
  21.   (rref (wptr view) :grafport.txSize))
  22.  
  23. (defun line-ascent ()
  24.   "Ascent of font in current grafport"
  25.   (rlet ((FontInfo :FontInfo))
  26.     (#_GetFontInfo FontInfo)
  27.     (rref FontInfo :FontInfo.ascent)))
  28.  
  29. (defun line-descent ()
  30.   "Descent of font in current grafport"
  31.   (rlet ((FontInfo :FontInfo))
  32.     (#_GetFontInfo FontInfo)
  33.     (rref FontInfo :FontInfo.descent)))
  34.  
  35. (defun line-leading ()
  36.   "Leading of font in current grafport"
  37.   (rlet ((FontInfo :FontInfo))
  38.     (#_GetFontInfo FontInfo)
  39.     (rref FontInfo :FontInfo.leading)))
  40.  
  41. (defun line-height ()
  42.   "Sum of ascent, descent and leading of font in current grafport"
  43.   (rlet ((FontInfo :FontInfo))
  44.     (#_GetFontInfo FontInfo)
  45.     (+ (rref FontInfo :FontInfo.ascent) 
  46.        (rref FontInfo :FontInfo.descent)
  47. ;       (rref FontInfo :FontInfo.leading)
  48.        )))
  49.  
  50. ;;; class definitions for graphic-view and graphic-window
  51. ;;;
  52.  
  53. (defclass graphic-view (pict-scroller)
  54.   ((selectable-p :accessor selectable-p :initarg :selectable-p :initform nil)
  55.    (top-object :accessor top-object :initform nil)
  56.    (selected-object :accessor selected-object :initform nil)
  57.    (graphic-generation :accessor graphic-generation :initform 0)))
  58.  
  59. (defclass graphic-window (pict-scrolling-window)
  60.   ((scroller-class :allocation :class
  61.                    :initform 'graphic-view)))
  62.  
  63. ;;; methods for graphic-view and graphic-window
  64. ;;;
  65.  
  66. (defmethod border-h ((view graphic-view))
  67.   10)
  68.  
  69. (defmethod border-v ((view graphic-view))
  70.   10)
  71.  
  72. (defmethod view-close ((view graphic-view))
  73.   (setf (top-object view) nil)
  74.   (call-next-method))
  75.  
  76. (defmethod view-draw-contents ((view graphic-view))
  77.   (call-next-method)
  78.   (let ((*the-view* view)
  79.         (selected-object (selected-object view)))
  80.     (when selected-object
  81.       (with-focused-view view
  82.         (highlight selected-object)))))
  83.  
  84. (defmethod view-click-event-handler ((view graphic-view) where)
  85.   (let ((*the-view* view)
  86.         (selected-object (selected-object view))
  87.         (top-object (top-object view)))
  88.     (with-focused-view view
  89.       (when selected-object
  90.         (deselect selected-object)
  91.         (setf (selected-object view) nil))
  92.       (when (and (selectable-p view) top-object)
  93.         (let ((new-selected-object (click-event-handler top-object where)))
  94.           (when new-selected-object
  95.             (setf (selected-object view) new-selected-object)
  96.             (select new-selected-object)))))))
  97.  
  98.  
  99. (defmethod draw-object ((window graphic-window) object &key selectable-p)
  100.   (draw-object (scroller window) object :selectable-p selectable-p))
  101.  
  102. (defmethod draw-object ((view graphic-view) object &key selectable-p)
  103.   (setf (selected-object view) nil)
  104.   (erase-view view)
  105.   (incf (graphic-generation view))
  106.   (with-focused-view view
  107.     (let* ((*the-view* view)               ; dynamically bind *the-view* to the view being laid out
  108.            (border-h (border-h view))
  109.            (border-v (border-v view))
  110.            (size-h (size-h object))
  111.            (size-v (size-v object)))
  112.       (with-pict-view view (make-point (+ size-h (* 2 border-h)) 
  113.                                        (+ size-v (* 2 border-v)))
  114.         (draw object border-h border-v))))
  115.   (setf (selectable-p view) selectable-p)
  116.   (setf (top-object view) object))
  117.         
  118. (defmethod set-view-font-codes ((window graphic-window) old-ff old-ms &optional ff-mask ms-mask)
  119.   (declare (ignore old-ff old-ms ff-mask ms-mask))
  120.   (call-next-method)
  121.   (when (slot-boundp window 'scroller)
  122.     (let* ((scroller (scroller window))
  123.            (top-object (top-object scroller))
  124.            (selectable-p (selectable-p scroller))
  125.            (selected-object (selected-object scroller)))
  126.       (when top-object
  127.         (draw-object scroller top-object :selectable-p selectable-p)
  128.         (when selected-object
  129.           (setf (selected-object scroller) selected-object)
  130.           (with-focused-view scroller
  131.             (highlight selected-object)))))))
  132.  
  133.  
  134. ;;; Simple graphic objects. These are objects that know how to draw themselves on to views
  135. ;;; and respond to mouse clicks.  Their instance variables are:
  136. ;;;
  137. ;;;  Instance Variable             Description
  138. ;;;  =================             ===========
  139. ;;;  top                           Location of top of object - set :before draw method
  140. ;;;  left                          Location of left of object - set :before draw method
  141. ;;;
  142. ;;; The methods that they must respond to are:
  143. ;;;
  144. ;;;  Method                        Description
  145. ;;;  ======                        ===========
  146. ;;;
  147. ;;;  size-h                        horizontal size of object - must be provided by subclass!
  148. ;;;  size-v                        vertical size of object - must be provided by subclass!
  149. ;;;  bottom                        bottom of object
  150. ;;;  right                         right of object
  151. ;;;  draw                          draws object - must be specialized by subclass!
  152. ;;;
  153. ;;;  border-XXXX                   border sizes around object
  154. ;;;
  155. ;;;  descendants                   selectable objects "inside" this one
  156. ;;;  selectable-p                  determines if this object can be clicked
  157. ;;;  click-event-handler           handles click inside of object
  158. ;;;  highlight                     draws (xors) dots around object
  159. ;;;  select                        called when object is selected (default highlights object)
  160. ;;;  deselect                      called when a selected object is deselected
  161. ;;;
  162.  
  163. (defclass simple-graphic-object () 
  164.   ((top :accessor top)
  165.    (left :accessor left)))
  166.  
  167. (defmethod bottom ((obj simple-graphic-object))
  168.   (+ (top obj) (size-v obj)))
  169.  
  170. (defmethod right ((obj simple-graphic-object))
  171.   (+ (left obj) (size-h obj)))
  172.  
  173. (defmethod draw :before ((obj simple-graphic-object) left top)
  174.   (setf (top obj) top)
  175.   (setf (left obj) left))
  176.  
  177.  
  178. (defmethod head ((obj simple-graphic-object))
  179.   (floor (size-h obj) 2))
  180.  
  181. (defmethod base ((obj simple-graphic-object))
  182.   (floor (size-v obj) 2))
  183.  
  184.  
  185. (defmethod descendants ((obj simple-graphic-object))
  186.   '())
  187.  
  188. (defmethod selectable-p ((obj simple-graphic-object))
  189.   nil)
  190.  
  191. (defmethod click-event-handler ((obj simple-graphic-object) where)
  192.   (if (and (<= (left obj) (point-h where) (right obj))
  193.            (<= (top obj) (point-v where) (bottom obj)))
  194.     (or (some #'(lambda (descendant) (click-event-handler descendant where))  ; click in
  195.               (descendants obj))                                              ;  descendant
  196.         (and (selectable-p obj) obj))                                         ; click in me
  197.     nil))                                                                     ; click not in me
  198.  
  199. (defmethod highlight ((obj simple-graphic-object))
  200.   (let* ((left (left obj))
  201.          (right (right obj))
  202.          (mid (floor (+ left right) 2)))
  203.     (rlet ((pen-state :penstate))
  204.       (#_GetPenState pen-state)
  205.       (#_PenNormal)
  206.       (#_PenSize 3 3)
  207.       (#_PenMode #.(position :patXor *pen-modes*))
  208.       (dolist (h `(,left ,mid ,right))
  209.         (dolist (v `(,(bottom obj) ,(top obj)))
  210.           (#_MoveTo h v)
  211.           (#_Line 1 0)))
  212.       (#_SetPenState pen-state))))
  213.  
  214. (defmethod select ((obj simple-graphic-object))
  215.   (highlight obj))
  216.  
  217. (defmethod deselect ((obj simple-graphic-object))
  218.   (highlight obj))
  219.  
  220. (defmethod border ((obj simple-graphic-object))
  221.   0)
  222.  
  223. (defmethod border-h ((obj simple-graphic-object))
  224.   (border obj))
  225.  
  226. (defmethod border-v ((obj simple-graphic-object))
  227.   (border obj))
  228.  
  229. (defmethod border-top ((obj simple-graphic-object))
  230.   (border-v obj))
  231.  
  232. (defmethod border-bottom ((obj simple-graphic-object))
  233.   (border-v obj))
  234.  
  235. (defmethod border-left ((obj simple-graphic-object))
  236.   (border-h obj))
  237.  
  238. (defmethod border-right ((obj simple-graphic-object))
  239.   (border-h obj))
  240.  
  241.  
  242. ;;; graphic-objects are simple-graphic-objects that cache their sizes and have borders
  243.  
  244. (defclass graphic-object (simple-graphic-object)
  245.   ((size-h :accessor size-h)
  246.    (size-v :accessor size-v)
  247.    (generation :accessor generation :initform -1)))
  248.  
  249. (defmethod update-if-necessary ((obj graphic-object))
  250.   (let ((graphic-generation (graphic-generation *the-view*)))
  251.     (unless (= (generation obj) graphic-generation)
  252.       (setf (generation obj) graphic-generation)
  253.       (multiple-value-bind (size-h size-v) (compute-size obj)
  254.         (setf (size-h obj) (+ (border-left obj) size-h (border-right obj)))
  255.         (setf (size-v obj) (+ (border-top obj) size-v (border-bottom obj)))))))
  256.  
  257. (defmethod size-h :before ((obj graphic-object))
  258.   (update-if-necessary obj))
  259.  
  260. (defmethod size-v :before ((obj graphic-object))
  261.   (update-if-necessary obj))
  262.  
  263. (defmethod draw ((obj graphic-object) left top)
  264.   (draw-obj obj (+ left (border-left obj)) (+ top (border-top obj))))
  265.  
  266. ;;; string objects
  267.  
  268. (defclass string-object (simple-graphic-object)
  269.   ((display-string :accessor display-string)))
  270.  
  271. (defmethod initialize-instance ((obj string-object) &key (string "*Unspecified*"))
  272.   (call-next-method)
  273.   (setf (display-string obj) (princ-to-string string)))
  274.  
  275. (defmethod size-h ((obj string-object))
  276.   (+ (border-left obj)
  277.      (string-width (display-string obj))
  278.      (border-right obj)))
  279.  
  280. (defmethod size-v ((obj string-object))
  281.   (+ (border-top obj)
  282.      (line-height)
  283.      (border-bottom obj)))
  284.  
  285. (defmethod base ((obj string-object))
  286.   (+ (border-top obj)
  287.      (line-ascent)))
  288.  
  289. (defmethod draw ((obj string-object) left top)
  290.   (#_MoveTo (+ left (border-left obj)) 
  291.             (+ top (base obj)))
  292.   (with-pstrs ((string (display-string obj)))
  293.     (#_DrawString string)))
  294.  
  295. ;;; small-string-objects are string objects in a smaller font size
  296.  
  297. (defclass small-string-object (string-object) ())
  298.  
  299. (defmacro with-font-size (font-size &body body)
  300.   (let ((txSize (gensym "txSize")))
  301.     `(let ((,txSize (font-size *the-view*)))
  302.        (unwind-protect (progn 
  303.                          (#_TextSize ,font-size)
  304.                          ,@body)
  305.          (#_TextSize ,txSize)))))
  306.  
  307. (defmethod small-font-size ((self small-string-object))
  308.   (max 9 (ceiling (* (font-size *the-view*) 3) 4)))
  309.  
  310. (defmethod size-h ((self small-string-object))
  311.   (with-font-size (small-font-size self)
  312.     (call-next-method)))
  313.  
  314. (defmethod size-v ((self small-string-object))
  315.   (with-font-size (small-font-size self)
  316.     (call-next-method)))
  317.  
  318. (defmethod draw ((self small-string-object) left top)
  319.   (let ((base (base self))
  320.         (border-left (border-left self)))
  321.     (with-font-size (small-font-size self)
  322.       (#_MoveTo (+ left border-left) (+ top base))
  323.       (with-pstrs ((string (display-string self)))
  324.         (#_DrawString string)))))
  325.  
  326. (defmethod base ((self small-string-object))
  327.   (with-font-size (small-font-size self)
  328.     (call-next-method)))
  329.  
  330. ;;; Sequences are composite objects. 
  331.  
  332. (defclass sequence-object (graphic-object)
  333.   ((objects :accessor objects :initarg :objects)
  334.    (offset :accessor offset)))
  335.  
  336. (defmethod empty-size ((self sequence-object))
  337.   0)
  338.  
  339. (defmethod empty-h ((self sequence-object))
  340.   (empty-size self))
  341.  
  342. (defmethod empty-v ((self sequence-object))
  343.   (empty-size self))
  344.  
  345. (defmethod alignment ((self sequence-object))
  346.   #'(lambda (o)
  347.       (declare (ignore o))
  348.       0))
  349.  
  350. (defmethod offset :before ((self sequence-object))
  351.   "Force a size calculation if this hasn't been done yet"
  352.   (update-if-necessary self))
  353.  
  354. ;;; horizontal-sequence is a subclass of graphic-object consisting of a
  355. ;;;  sequence of other graphic objects, which will be laid out in a
  356. ;;;  line.  An empty horizontal-sequence has zero size.
  357.  
  358. (defclass horizontal-sequence (sequence-object) ())
  359.  
  360. (defmethod gap-h ((self horizontal-sequence))
  361.   "Gap between objects"
  362.   (round (line-height)
  363.          2))
  364.  
  365. (defmethod compute-size ((self horizontal-sequence))
  366.   (let* ((objects (objects self))
  367.          (alignment (alignment self))
  368.          (offset (reduce #'max objects :key alignment :initial-value 0)))
  369.     (setf (offset self) offset)
  370.     (if (null objects)
  371.       (values (empty-h self) (empty-v self))
  372.       (values (+ (reduce #'+ objects :key #'size-h)            ; horizontal size is sum of object's size
  373.                  (* (1- (length objects)) (gap-h self)))       ;  plus gap
  374.               (+ offset
  375.                  (reduce #'max objects 
  376.                          :key #'(lambda (obj)
  377.                                   (- (size-v obj) (funcall alignment obj)))))))))
  378.  
  379. (defmethod draw-obj ((self horizontal-sequence) left top)
  380.   (let ((objects (objects self))
  381.         (alignment (alignment self))
  382.         (gap-h (gap-h self))
  383.         (offset (offset self)))
  384.     (when objects
  385.       (flet ((pos (obj)
  386.                (+ top (- offset (funcall alignment obj)))))
  387.         (draw (first objects) left (pos (first objects)))
  388.         (incf left (+ gap-h (size-h (first objects))))
  389.         (dolist (obj (rest objects))
  390.           (draw obj left (pos obj))
  391.           (incf left (+ (size-h obj) gap-h)))))))
  392.         
  393. ;;; vertical-sequence is a subclass of graphic-object consisting of an aligned
  394. ;;;  sequence of vertical objects.
  395.  
  396. (defclass vertical-sequence (sequence-object) ())
  397.  
  398. (defmethod gap-v ((self vertical-sequence))
  399.   "Gap between objects"
  400.   (line-leading))
  401.  
  402. (defmethod empty ((self vertical-sequence))
  403.   (ceiling (* 2 (line-height)) 3))
  404.  
  405. (defmethod compute-size ((self vertical-sequence))
  406.   (let* ((objects (objects self))
  407.          (alignment (alignment self))
  408.          (offset (reduce #'max objects :key alignment :initial-value 0)))
  409.     (setf (offset self) offset)
  410.     (if (null objects)
  411.       (values (empty-h self) (empty-v self))
  412.       (values (+ offset
  413.                  (reduce #'max objects 
  414.                          :key #'(lambda (obj)
  415.                                   (- (size-h obj) (funcall alignment obj)))))
  416.               (+ (reduce #'+ objects :key #'size-v)            ; vertical size is sum of object's size
  417.                  (* (1- (length objects)) (gap-v self)))))))   ;  plus gap
  418.  
  419. (defmethod draw-obj ((self vertical-sequence) left top)
  420.   (let ((objects (objects self))
  421.         (alignment (alignment self))
  422.         (gap-v (gap-v self))
  423.         (offset (offset self)))
  424.     (when objects
  425.       (flet ((pos (obj)
  426.                (+ left (- offset (funcall alignment obj)))))
  427.         (draw (first objects) (pos (first objects)) top)
  428.         (incf top (+ gap-v (size-v (first objects))))
  429.         (dolist (obj (rest objects))
  430.           (draw obj (pos obj) top)
  431.           (incf top (+ (size-v obj) gap-v)))))))
  432.  
  433. (defmethod base ((self vertical-sequence))
  434.   (let ((objects (objects self)))
  435.     (if (= (length objects) 1)
  436.       (+ (border-top self) (base (first objects)))
  437.       (call-next-method))))
  438.  
  439. ;;; tree objects consist of a vertical sequence consisting of the root and
  440. ;;; a horizontal sequence of subtrees
  441.  
  442. (defclass tree-object (vertical-sequence) ())
  443.  
  444. (defclass subtrees-object (horizontal-sequence) ())
  445.  
  446. (defmethod initialize-instance ((tree tree-object) &key root subtrees)
  447.   (call-next-method)
  448.   (setf (objects tree) (list root (make-instance 'subtrees-object :objects subtrees))))
  449.  
  450. (defmethod root ((tree tree-object))
  451.   (first (objects tree)))
  452.  
  453. (defmethod subtrees ((tree tree-object))
  454.   (objects (second (objects tree))))
  455.  
  456. (defmethod gap-v ((tree tree-object))
  457.   (line-height))
  458.  
  459. (defmethod selectable-p ((tree tree-object))
  460.   "The whole tree (as an object) is selectable"
  461.   t)
  462.  
  463. (defmethod descendants ((tree tree-object))
  464.   "The selectable components of a tree are its subtrees"
  465.   (subtrees tree))
  466.  
  467. (defmethod base ((tree tree-object))
  468.   (+ (border-top tree) (base (root tree))))
  469.  
  470. (defmethod alignment ((tree tree-object))
  471.   #'head)
  472.  
  473. (defmethod head ((tree tree-object))
  474.   (+ (border-left tree)
  475.      (offset tree)))
  476.  
  477. (defmethod head ((obj subtrees-object))
  478.   "The head of a subtree is the average of the head of its first and last subtrees"
  479.   (let ((objects (objects obj)))
  480.     (if (null objects)
  481.       (call-next-method)
  482.       (let* ((lefttree (first objects))
  483.              (righttree (car (last objects)))
  484.              (rightobj-head (- (size-h obj) (border-left obj) (border-right obj)
  485.                                (- (size-h righttree) (head righttree)))))
  486.         (+ (border-left obj) (floor (+ (head lefttree) rightobj-head) 2))))))
  487.  
  488. (defmethod draw ((tree tree-object) left top)
  489.   "The default methods position and draw the objects, so all we have to do is draw the lines"
  490.   (declare (ignore left top))
  491.   (call-next-method)
  492.   (let* ((root (root tree))
  493.          (root-bottom (+ (line-leading) (bottom root)))
  494.          (root-head (+ (left root) (head root))))
  495.     (dolist (subtree (subtrees tree))
  496.       (let ((subtree-top (- (top subtree) 2))
  497.             (subtree-head (+ (left subtree) (head subtree))))
  498.         (when (< -2 (- root-head subtree-head) 2)
  499.           (setf subtree-head root-head))
  500.         (#_MoveTo root-head root-bottom)
  501.         (#_LineTo subtree-head subtree-top)))))
  502.  
  503.  
  504. (defun list-to-tree (list)
  505.   "Translates a list into a tree object"
  506.   (if (consp list)
  507.     (make-instance 'tree-object
  508.                    :root (list-to-tree (first list))
  509.                    :subtrees (mapcar #'list-to-tree (rest list)))
  510.     (make-instance 'string-object :string list)))
  511.  
  512. ;;; drawtree draws a tree in its own window
  513.  
  514. (defun drawtree (tree &key selectable-p)
  515.   "Draws a tree in its own tree window"
  516.   (if (listp tree)
  517.     (setf tree (list-to-tree tree)))
  518.   (let ((front-window (front-window)))
  519.     (unless (and (typep *tree-window* 'graphic-window)
  520.                  (wptr *tree-window*))
  521.       (setf *tree-window* (make-instance 'graphic-window
  522.                                          :window-title "Tree Window"
  523.                                          :view-size #@(200 200))))
  524.     (draw-object *tree-window* tree :selectable-p selectable-p)
  525.     (window-show *tree-window*)
  526.     (window-select *tree-window*)
  527.     (window-select front-window)))
  528.  
  529.  
  530. ;;; bracket-mixin adds a bracket surrounding the object
  531. ;;;
  532.  
  533. (defclass bracket-mixin () ())
  534.  
  535. (defmethod border-h ((self bracket-mixin))
  536.   (max (1+ (floor (line-height) 3)) 
  537.        (call-next-method)))
  538.  
  539. (defmethod border-v ((self bracket-mixin))
  540.   (max 3
  541.        (call-next-method)))
  542.  
  543. (defmethod draw :after ((self bracket-mixin) left top)
  544.   (declare (ignore left top))
  545.   (let ((bracket-width (floor (line-height) 3)))
  546.     (#_MoveTo (+ (left self) bracket-width) (1+ (top self)))
  547.     (#_Line (- bracket-width) 0)
  548.     (#_LineTo (left self) (1- (bottom self)))
  549.     (#_Line bracket-width 0)
  550.     (#_MoveTo (- (right self) bracket-width) (1+ (top self)))
  551.     (#_Line bracket-width 0)
  552.     (#_LineTo (right self) (1- (bottom self)))
  553.     (#_Line (- bracket-width) 0)))
  554.  
  555.  
  556. ;;; brace-mixin adds a parenthesis or brace around the object
  557. ;;;
  558.  
  559.  
  560. (defclass brace-mixin () ())
  561.  
  562. (defmethod brace-size ((self brace-mixin))
  563.   (max 2 
  564.        (floor (line-height) 8)))
  565.  
  566. (defmethod border-h ((self brace-mixin))
  567.   (max (+ 2 (* 2 (brace-size self)))
  568.        (call-next-method)))
  569.  
  570. (defmethod border-v ((self brace-mixin))
  571.   (max (brace-size self)
  572.        (call-next-method)))
  573.  
  574. (defmethod draw :after ((self brace-mixin) left top)
  575.   (declare (ignore left top))
  576.   (let* ((brace-size (brace-size self))
  577.          (left (+ (left self) brace-size))
  578.          (top (+ (top self) brace-size))
  579.          (right (- (right self) brace-size))
  580.          (bottom (- (bottom self) brace-size))
  581.          (mid (round (+ top bottom) 2)))
  582.     (#_MoveTo left top)
  583.     (#_Line brace-size (- brace-size))
  584.     (#_MoveTo left top)
  585.     (#_LineTo left (- mid brace-size))
  586.     (#_Line (- brace-size) brace-size)
  587.     (#_Line brace-size brace-size)
  588.     (#_LineTo left bottom)
  589.     (#_Line brace-size brace-size)
  590.     (#_MoveTo right top)
  591.     (#_Line (- brace-size) (- brace-size))
  592.     (#_MoveTo right top)
  593.     (#_LineTo right (- mid brace-size))
  594.     (#_Line brace-size brace-size)
  595.     (#_Line (- brace-size) brace-size)
  596.     (#_LineTo right bottom)
  597.     (#_Line (- brace-size) brace-size)))
  598.  
  599.  
  600. ;;; angle-bracket-mixin adds an angle-bracket around the object
  601. ;;;
  602.  
  603.  
  604. (defclass angle-bracket-mixin () ())
  605.  
  606. (defmethod angle-bracket-size ((self angle-bracket-mixin))
  607.   (floor (* 2 (line-height)) 3))
  608.  
  609. (defmethod border-h ((self angle-bracket-mixin))
  610.   (max (+ 2 (angle-bracket-size self))
  611.        (call-next-method)))
  612.  
  613. (defmethod draw :after ((self angle-bracket-mixin) left top)
  614.   (declare (ignore left top))
  615.   (let* ((angle-bracket-size (angle-bracket-size self))
  616.          (left (+ (left self) angle-bracket-size))
  617.          (top (top self))
  618.          (right (- (right self) angle-bracket-size))
  619.          (bottom (bottom self))
  620.          (mid (round (+ top bottom) 2)))
  621.     (#_MoveTo left top)
  622.     (#_LineTo (- left angle-bracket-size) mid)
  623.     (#_LineTo left bottom)
  624.     (#_MoveTo right top)
  625.     (#_LineTo (+ right angle-bracket-size) mid)
  626.     (#_LineTo right bottom)))
  627.  
  628.  
  629. ;;; box-mixin adds a rectangle box around the object
  630. ;;;
  631.  
  632. (defclass box-mixin () ())
  633.  
  634. (defmethod draw :after ((self box-mixin) left top)
  635.   (declare (ignore left top))
  636.   (rlet ((r :rect
  637.             :topleft (make-point (left self) (1+ (top self)))
  638.             :bottomright (make-point (right self) (1- (bottom self)))))
  639.     (#_FrameRect r)))
  640.  
  641. ;;; Here is the AV interface.
  642. ;;;
  643. ;;; avm-object ---> index-object
  644. ;;;             |
  645. ;;;             |-> avm-bracket-object  --->  A   o
  646. ;;;                                      |    V   b
  647. ;;;                                      |->      j
  648. ;;;                                      |    p   e
  649. ;;;                                      |->  a   c
  650. ;;;                                      |    i   t
  651. ;;;                                     ...   r   s
  652.  
  653. ;;; index-objects are the cute little boxed integers that decorate AVMs
  654.  
  655. (defclass index-object (box-mixin small-string-object) ())
  656.  
  657. (defmethod border-h ((self index-object))
  658.   (max 2 (call-next-method)))
  659.  
  660. (defmethod border-bottom ((self index-object))
  661.   (max 1 (call-next-method)))
  662.  
  663. (defmethod border-top ((self index-object))
  664.   (max 2 (call-next-method)))
  665.  
  666. ;;; avm-bracket-objects are the bracketted parts of the AVM.
  667.  
  668. (defclass avm-bracket-object (bracket-mixin vertical-sequence) ())
  669.                                         
  670. (defclass avm-object (horizontal-sequence) 
  671.   ((avm-bracket :reader avm-bracket :initform (make-instance 'avm-bracket-object))
  672.    (index :accessor index :initform nil)))
  673.  
  674. (defclass avm-pair (horizontal-sequence) ())
  675.  
  676. (defmethod alignment ((self avm-object))
  677.   #'size-v)
  678.  
  679. (defmethod alignment ((self avm-pair))
  680.   #'base)
  681.  
  682. (defmethod base ((self avm-pair))
  683.   (+ (border-top self)
  684.      (offset self)))
  685.  
  686. (defmethod base ((self avm-object))
  687.   (+ (border-top self) (base (avm-bracket self))))
  688.  
  689. (defmethod base ((self avm-bracket-object))
  690.   (if (null (objects self))
  691.     (+ (floor (size-v self) 2) (line-descent))
  692.     (call-next-method)))
  693.  
  694. (defmethod objects ((self avm-object))
  695.   (let ((index (index self))
  696.         (avm-bracket (avm-bracket self)))
  697.     (if index
  698.       (list index avm-bracket)
  699.       (list avm-bracket))))
  700.  
  701. (defmethod gap-h ((self avm-object))
  702.   "Gap between index and avm-bracket"
  703.   (round (line-height)
  704.          4))
  705.  
  706. (defmethod gap-h ((self avm-pair))
  707.   (string-width " "))
  708.  
  709. (defmethod empty-h ((self avm-bracket-object))
  710.   4)
  711.  
  712. (defmethod empty-v ((self avm-bracket-object))
  713.   (line-ascent))
  714.  
  715. (defmethod set-avm-pairs ((self avm-object) avm-pairs)
  716.   (setf (objects (avm-bracket self)) avm-pairs))
  717.  
  718. (defun make-avm-pair (attribute value)
  719.   "Make the AV pair"
  720.   (make-instance 'avm-pair
  721.                  :objects `(,(make-instance 'string-object 
  722.                                             :string (format nil "~a =" attribute))
  723.                             ,value)))
  724.  
  725.  
  726.